home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / mail.swg / 0017_QWK packets to text.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-02-03  |  6.2 KB  |  212 lines
  1. {DAT2TXT v0.90- Free DOS utility: Converts .QWK MESSAGES.DAT to text.}
  2. {$V-,S-}
  3. program DAT2TXT ;
  4. uses dos ;
  5. const
  6.    Seperator = '---------------------------------------------------------------------------' ;
  7.    herald    = '===========================================================================' ;
  8. type
  9.    CharArray = array[1..6] of char ;  { to read in chunks }
  10.  
  11.    MSGDATHdr = record  { ALSO the format for SWAG files !!! }
  12.       Status   : char ;
  13.       MSGNum   : array [1..7] of char ;
  14.       Date     : array [1..8] of char ;
  15.       Time     : array [1..5] of char ;
  16.       UpTO     : array [1..25] of char ;
  17.       UpFROM   : array [1..25] of char ;
  18.       Subject  : array [1..25] of char ;
  19.       PassWord : array [1..12] of char ;
  20.       ReferNum : array [1..8] of char ;
  21.       NumChunk : CharArray ;
  22.       Alive    : byte ;
  23.       LeastSig : byte ;
  24.       MostSig  : byte ;
  25.       Reserved : array [1..3] of char ;
  26.    end ;
  27.  
  28. var
  29.    F           : file ;
  30.    txtfile     : text ;
  31.  
  32. procedure showhelp(problem:byte); {if any *foreseen* errors arise, we are sent}
  33.                              { here to give a little help and exit peacefully }
  34. const
  35.  progdata = 'DAT2TXT v0.90- Free DOS utility: Converts .QWK MESSAGES.DAT to text.';
  36.  progdat2 = '(By SWAG contributors.)';
  37.  usage    = 'Usage:  DAT2TXT infile(s) [/o]';
  38.  usag2    = 'The "/o" causes DAT2TXT to overwrite (not append to) existing messages.txt.';
  39.  note     = 'DOS * and ? wildcards ok with "infile(s)".  Output is always to MESSAGES.TXT.';
  40. var
  41.    message : string[80];
  42. begin
  43.    writeln(progdata);                  { just tell user what this program   }
  44.    writeln(progdat2);                  { is and who wrote it                }
  45.    writeln;
  46.    writeln(usage);
  47.    writeln(usag2);
  48.    writeln(note);
  49.    writeln;
  50.    writeln('Error encountered:');
  51.    case problem of
  52.      1 : message := 'Incorrect number of parameters.';
  53.      { plenty of room for other errors! }
  54.    else
  55.         message := 'Unknown error.';
  56.    end;
  57.    writeln(message);
  58.    halt(problem);
  59. end;
  60.  
  61. function converttoupper(w : string) : string;
  62. var
  63.    cp  : integer;        {the position of the character to change.}
  64. begin
  65.      for cp := 1 to length(w) do
  66.          w[cp] := upcase(w[cp]);
  67.      converttoupper := w;
  68. end;
  69.  
  70. function ArrayTOInteger ( B : CharArray ; Len : byte ) : longint ;
  71.  
  72. var I : byte ;
  73.     S : string ;
  74.     E : integer ;
  75.     T : integer ;
  76.  
  77. begin
  78.    S := '' ;
  79.    for I := 1 to Len do
  80.       if B[i] <> #32 then S := S + B[i] ;
  81.  
  82.    Val ( S, T, E );
  83.  
  84.    if E = 0 then
  85.       ArrayToInteger := T
  86.    else
  87.       ArrayToInteger := 0 ;
  88. end ;
  89.  
  90. procedure ReadWriteHdr ( var HDR : MSGDatHdr );
  91. begin
  92.    BlockRead ( F, Hdr, 1 );
  93.    if ArrayToInteger ( Hdr.NumChunk, 6 ) <> 0 then
  94.       with Hdr do begin
  95.          writeln ( txtfile, herald );
  96.          write ( txtfile, 'Date: ', Date, ' (', Time, ')' );
  97.          writeln ( txtfile, '' : 23, 'Number: ', MSGNum );
  98.          write ( txtfile, 'From: ', UpFROM );
  99.          writeln ( txtfile, '' : 14, 'Refer#: ', ReferNum );
  100.          write ( txtfile, '  To: ', UpTO );
  101.          write ( txtfile, '' : 15, 'Recvd: ' );
  102.          if Status in ['-', '`', '^', '#'] then
  103.             writeln ( txtfile, 'YES' )
  104.          else
  105.             writeln ( txtfile, 'NO' );
  106.          write ( txtfile, 'Subj: ', Subject );
  107.          writeln ( txtfile, '' : 16, 'Conf: ', '(', (MostSig * 256) + LeastSig, ')' );
  108.          writeln ( txtfile, Seperator );
  109.       end ;
  110. end ;
  111.  
  112. procedure ReadMSG ( NumChunks : integer );
  113. var
  114.    Buff : array [1..128] of char ;
  115.    J    : integer ;
  116.    I    : byte ;
  117.  
  118. begin
  119.    for J := 1 to PRED ( NumChunks ) do begin
  120.       BlockRead ( F, Buff, 1 );
  121.       for I := 1 to 128 do
  122.          if Buff [I] = #$E3 then
  123.             writeln ( txtfile )
  124.          else
  125.             write ( txtfile, Buff [I] );
  126.    end ;
  127. end ;
  128.  
  129. procedure ReadMessage ( HDR : MSGDatHdr ; RelNum : longint ; var Chunks : integer );
  130. begin
  131.    Seek ( F, RelNum - 1 );
  132.    ReadWriteHdr ( HDR );
  133.    Chunks := ArrayToInteger ( HDR.NumChunk, 6 );
  134.    if Chunks <> 0 then begin
  135.       ReadMsg ( Chunks );
  136.       writeln ( txtfile );
  137.    end
  138.    else
  139.       Chunks := 1 ;
  140. end ;
  141.  
  142. var
  143.    MSGHdr   : MSGDatHdr ;
  144.    repordat : boolean ;
  145.    ch       : char ;
  146.    count    : integer ;
  147.    chunks   : integer ;
  148.    defsavefile : string ;
  149.    fileinfo : searchrec ;
  150.    fdt      : longint ;
  151.    ps1,ps2  : string [2] ;
  152.    fileexists,
  153.    overwrite  : boolean ;
  154.    response   : char ;
  155.  
  156.    dpath, tpath  : pathstr ;
  157.    {epath & dpath are fully qualified pathnames of .dat & .txt files}
  158.  
  159.    ddir,  tdir   : dirstr ;
  160.    dname, tname  : namestr ;
  161.    d_ext, t_ext  : extstr ;
  162.    txtfileinfo   : searchrec ;
  163.  
  164. begin
  165.    if ( paramcount < 1) or ( paramcount > 2) then showhelp(1);
  166.    ps1 := converttoupper ( paramstr (1));
  167.    if (ps1 = '/H') or (ps1 = '/?') or
  168.       (ps1 = '-H') or (ps1 = '-?') then showhelp(0);
  169.  
  170.    DefSaveFile := '' ;
  171.    ps2 := '/A' ;
  172.    if paramcount > 1 then ps2 := paramstr ( 2 );
  173.    overwrite := (upcase ( ps2[2] ) = 'O');
  174.    dpath := fexpand ( paramstr ( 1 ) );
  175.    fsplit ( dpath, ddir, dname, d_ext );
  176.    { break up path into components }
  177.    findfirst ( dpath, anyfile, fileinfo );
  178.    while doserror = 0 do begin
  179.       fsplit ( fexpand ( fileinfo.name ), tdir, tname, t_ext );
  180.       dpath := ddir + fileinfo.name ;
  181.       tpath := ddir + tname + '.TXT' ;
  182.       Assign ( F, dpath );
  183.       { whatever file .. ( MESSAGES.DAT for .QWK ) }
  184.       Reset ( F, SizeOf ( MsgHdr ) );
  185.  
  186.       assign ( txtfile, tpath );
  187. {$i-} reset ( txtfile ); {$i+}
  188.       fileexists := (ioresult = 0);
  189.  
  190.       if fileexists then close ( txtfile );
  191.       if fileexists and ( not overwrite ) then
  192.          append ( txtfile )
  193.       else
  194.          rewrite ( txtfile );
  195.  
  196.       write ( 'DAT2TXT: ', dpath, ' to: ', tpath );
  197.       Count := 2 ;                     { start at RECORD #2 }
  198.       while Count < FileSize ( F ) do begin
  199.          ReadMessage ( MSGHdr, Count, Chunks );
  200.          INC ( Count, Chunks );
  201.       end ;
  202.  
  203.       getftime ( F, fdt );
  204.       close ( F ); close ( txtfile ); reset ( txtfile );
  205.       setftime ( txtfile , fdt );
  206.       close ( txtfile );
  207.  
  208.       writeln ( ', done!' );
  209.       findnext ( fileinfo );
  210.    end ;
  211. end.
  212.